Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/misc/volume25/sybperl/part01

Text File | 1991-11-11 | 34.1 KB | 1,299 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Michael Peppler)
Subject:  v25i040:  sybperl - Sybase DB-Library extensions to Perl, Part01/01
Message-ID: <[e-mail]>
X-Md4-Signature: d31b859697401b04dcea356a3727d11d
Date: Sun, 10 Nov 1991 20:05:58 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Michael Peppler)
Posting-number: Volume 25, Issue 40
Archive-name: sybperl/part01
Environment: UNIX, Perl, Sybase

This is Sybperl, a set of subroutine extensions to Perl to interface
directly to a Sybase dataserver.

Sybperl is very usefull for writing ad-hoc reports, when other tools
are too cumbersome for the task. I use sybperl for all the reports in a
production environment here at ITF Management.

Sybperl has been tested at a number of sites, and should work with no
problem provided Perl works on your system.

Michael Peppler                 [e-mail] {uunet,mcsun}!chsun!itf1!mpeppler
ITF Management SA            BIX:   mpeppler
13 Rue de la Fontaine        Phone: [phone]
CH-1204 Geneva, Switzerland  Fax:   [phone]
---------
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#    README
#    PACKING.LST
#    BUGS
#    Makefile
#    sybperl.c
#    sybperl.1
#    patchlevel.h
#    lib/sybperl.pl
#    t/sbex.pl
#
# Wrapped by [e-mail] on Mon Nov  4 16:34:43 MET 1991
#
if test -f 'README'
then
    echo shar: will not over-write existing file "'README'"
else
    echo x - 'README'
    sed 's/^X//' >'README' << 'SHAR_EOF'
X
X                 Sybperl, version 1.0
X
X
X
X   Sybperl is a set of user-defined subroutines letting you access a
X   Sybase data server using Perl.
X
X   Requirements: Perl ver 3.0.27 or higher.
X         Sybase DB-Library (aka Open Client)
X
X
X   Unshar somewhere convenient, and edit Makefile to reflect your
X   system setup. The PERL_VERSION macro needs to be uncommented if you
X   are compiling sybperl for Perl version 3.xx. The Makefile will not
X   attempt to build uperl.o if it can't find it.
X
X   You'll also need to edit the lib/sybperl.pl file to addapt it to
X   your environment.
X
X   There are some test scripts in the t directory which you can run to
X   see if all is well, and to get an idea of what can be done with sybperl.
X
X   Sybperl has been tested succesfully in the following environments:
X
X   Sun Sparc, SunOS 4.1.1, Sybase 4.0.1, Perl 4.010
X   Sun 3/80, SunOS 4.0.3, Sybase 4.0.1, Perl 4.010
X   Sun Sparc, SunOS 4.1, Sybase 4.2, Perl 4.010
X   Pyramid MIServer 2/2, OSx V5.1a, Sybase 4.0, Perl 4.010
X
X   I use sybperl daily in a production environment on a Sun 4/65 under
X   SunOS 4.1.1, with Sybase version 4.0.1.
X
X   BUGS:
X
X   There seems to be a major incompatibility between Perl and
X   DB-Library, but I've been able to code around it. See the BUGS file
X   for details.
X
X
X
X   Have fun using it and let me know of any improvements, problems,
X   whatever...
X
X   Michael Peppler            [e-mail] {uunet,mcsun}!chsun!itf1!mpeppler
X   ITF Management SA            BIX:   mpeppler
X   13 Rue de la Fontaine        Phone: [phone]
X   CH-1204 Geneva, Switzerland  Fax:   [phone]
X
X
X
X                   NOTICE - Warranty and Copyright
X
X
X   Sybperl is not a product of ITF Management. There is no warranty,
X   and no official support.
X
X   Sybperl is copyright, but may be freely distributed under the
X   same terms as Perl itself.
X
X
X
X   My thanks to the following people for testing Perl:
X
X   Teemu Torma
X   Matthew Merzbacher
X   Dan Banay
X   Jeffrey Wong
X   Anders Ardo
X   Minh Ton Ha
X   Gijs Mos
X   G. Roderick Singleton
X   Peter Gutmann
X
SHAR_EOF
if test 2105 -ne "`wc -c < 'README'`"
then
    echo shar: error transmitting "'README'" '(should have been 2105 characters)'
fi
fi
chmod 664 README
if test -f 'PACKING.LST'
then
    echo shar: will not over-write existing file "'PACKING.LST'"
else
    echo x - 'PACKING.LST'
    sed 's/^X//' >'PACKING.LST' << 'SHAR_EOF'
X
X
X
X    The Sybperl package should contain the following files:
X
X
X        PACKING.LST        This file
X        README        Read Me!
X        BUGS        Perl/DB-library incompatibility descritpion
X        Makefile
X        sybperl.c        Sybperl source
X        sybperl.1        Man page
X        patchlevel.h
X        t/sbex.pl        Example of sybperl script
X        lib/sybperl.pl  A Perl library file.
SHAR_EOF
if test 358 -ne "`wc -c < 'PACKING.LST'`"
then
    echo shar: error transmitting "'PACKING.LST'" '(should have been 358 characters)'
fi
fi
chmod 664 PACKING.LST
if test -f 'BUGS'
then
    echo shar: will not over-write existing file "'BUGS'"
else
    echo x - 'BUGS'
    sed 's/^X//' >'BUGS' << 'SHAR_EOF'
X
X
X    The Sybase DB-Library - Perl savestr() conflict
X    ------------------------------------------------
X
X
X    Ah! The joys of tying different packages together!
X
X    Both Perl and DB-Library have a function called savestr(). The
X    DB-Library version is used in dbcmd() to add an SQL command to the
X    list of commands pointed to by dpproc->dbcmdbuf, and in dbuse() as
X    well. Now there are several ways to work around this problem.
X
X    1) Compile sybperl.c with -DBROKEN_DBCMD. I've written some code
X       that emulates calls to dbcmd() and dbuse(). This works OK on my
X       machine/OS/Version of Perl/Version of DBlib, but it relies on
X       the internal storing method used by DBlib, and that might
X       change in the future.
X
X    2) Recompile Perl (specifically, uperl.o in the Perl source
X       directory) with some suitable flags (eg -Dsavestr=p_savestr).
X       This does not create any compatibility problems, but is a
X       lengthy procedure.
X
X    3) Do something like:
X       cc -c sybperl.c
X       ld -r -o sybperl2.o sybperl.o -lsybdb
X       [edit sybperl2.o and replace `_savestr' with something like `_savest1']
X       cc -o sybperl uperl.o sybperl2.o
X       This is not a bad solution, but won't work if you have shared
X       library versions of libsybdb.a
X
X    4) Edit uperl.o and replace savestr with something else. This is
X       the solution I've chosen as the default. It is relatively fast,
X       does not rely on any internal knowledge of DB-Library, and does
X       not require Perl to be recompiled.
X
X    The Makefile gives some information on how to achieve these
X    different options.
X
X    Thanks to Teemu Torma for providing the initial input on this problem.
X
X
X    Michael
SHAR_EOF
if test 1734 -ne "`wc -c < 'BUGS'`"
then
    echo shar: error transmitting "'BUGS'" '(should have been 1734 characters)'
fi
fi
chmod 664 BUGS
if test -f 'Makefile'
then
    echo shar: will not over-write existing file "'Makefile'"
else
    echo x - 'Makefile'
    sed 's/^X//' >'Makefile' << 'SHAR_EOF'
X#    @(#)Makefile    1.4    9/9/91
X#
X
XCC = cc
XPERLSRC = ..                # where to find uperl.o
XSYBINCS = /usr/local/sybase/include    # where to find the sybase .h files
XLOCINCS =                # other includes ?
XSYBLIBDIR = /usr/local/lib        # Sybase libraries
XSYBLIBS = -lsybdb            # db-library
X
X# Uncomment this if you are compiling sybperl for Perl version 3.xx
X
X# PERL_VERSION = -DVERSION3
X
X# The Perl/Sybase savestr() conflict.
X# Both Perl and Sybase DB-Library have a function called savestr(),
X# and this creates a problem when using functions such as dbcmd().
X# There are several ways around this.
X# You can:
X#
X#    - define BROKEN_DBCMD: this enables some code emulating
X#      dbcmd() that I've written.
X#    - Recompile uperl.o with a -Dsavestr=psvestr (or something similar).
X#    - Edit an existing uperl.o and change _savestr to _psvestr.
X#
X# To use the first option, uncomment the following definitions for
X# SAVESTR and UPERL
X# SAVESTR = -DBROKEN_DBCMD
X# UPERL = $(PERLSRC)/uperl.o
X#
X# To use the second option, you have to reconfigure & recompile Perl
X# manually, and then set compile sybperl with the following line
X# uncommented:
X# UPERL = $(PERLSRC)/uperl.o
X#
X# The default is to use the third solution:
XUPERL = uperl2.o
X
X
XCFLAGS = -O                 #
XCPPFLAGS = -I$(PERLSRC) -I$(LOCINCS) -I$(SYBINCS) $(PERL_VERSION) $(SAVESTR)
XBINDIR = /usr/local/bin            # where does the executable go
XPERLLIB = /usr/local/lib/perl        # where does lib/sybperl.pl go
XMANDIR = /usr/local/man            # where do we put the manual page
XMANEXT = l
X
X
Xsybperl: $(UPERL) sybperl.o
X    $(CC) $(CFLAGS) -L$(SYBLIBDIR) $(UPERL) sybperl.o $(SYBLIBS) -lm -o sybperl
X
Xsybperl.o: sybperl.c
X    $(CC) -c $(CFLAGS) $(CPPFLAGS) sybperl.c
X
X# Create uperl.o IF you wish to use the 3rd way of resolving the
X# Perl/Sybase savestr conflict.
X$(UPERL): $(PERLSRC)/uperl.o
X    cp $(PERLSRC)/uperl.o $(UPERL)
X    perl -p -i.bak -e 's/savestr/psvestr/g;' $(UPERL)
X
Xclean:
X    rm -f sybperl *.o *~
X
Xinstall: sybperl
X    install -s -m 775 sybperl $(BINDIR)
X    cp lib/sybperl.pl $(PERLLIB)/perllib.pl
X    pc sybperl.1 $(MANDIR)/man$(MANEXT)/sybperl.$(MANEXT)
X
Xshar:
X    rm -f sybperl.shar
X    shar.pl README PACKING.LST BUGS Makefile sybperl.c sybperl.1 patchlevel.h lib/sybperl.pl t/sbex.pl >sybperl.shar
X

SHAR_EOF
if test 2188 -ne "`wc -c < 'Makefile'`"
then
    echo shar: error transmitting "'Makefile'" '(should have been 2188 characters)'
fi
fi
chmod 444 Makefile
if test -f 'sybperl.c'
then
    echo shar: will not over-write existing file "'sybperl.c'"
else
    echo x - 'sybperl.c'
    sed 's/^X//' >'sybperl.c' << 'SHAR_EOF'
Xstatic char SccsId[] = "@(#)sybperl.c    1.5    9/9/91";
X/************************************************************************/
X/*    Copyright 1991 by Michael Peppler and ITF Management SA     */
X/*                                    */
X/*    Full ownership of this software, and all rights pertaining to     */
X/*    the for-profit distribution of this software, are retained by     */
X/*    Michael Peppler and ITF Management SA.  You are permitted to     */
X/*    use this software without fee.  This software is provided "as     */
X/*    is" without express or implied warranty.  You may redistribute     */
X/*    this software, provided that this copyright notice is retained,    */
X/*    and that the software is not distributed for profit.  If you     */
X/*    wish to use this software in a profit-making venture, you must     */
X/*    first license this code and its underlying technology from     */
X/*    ITF Management SA.                         */
X/*                                    */
X/*    Bottom line: you can have this software, you can use it, you     */
X/*    can give it away.  You just can't sell any or all parts of it     */
X/*    without prior permission from Harris Corporation.         */
X/************************************************************************/
X
X/* sybase.c
X *
X * Call Sybase DB-Library functions from Perl.
X * Written by Michael Peppler ([e-mail])
X * ITF Management SA, 13 rue de la Fontaine
X * CH-1204 Geneva, Switzerland
X * Tel: [phone] Fax: [phone]
X */
X
X
X/*
X * The Perl/Sybase savestr() conflict.
X * Both Perl and Sybase DB-Library have a function called savestr().
X * This creates a problem when calling dbcmd() and dbuse(). There are
X * several ways to work around this, one of which is to #define
X * BROKEN_DBCMD, which enables some code that I've written to simulate
X * dbcmd() locally. See Makefile and BUGS for details.
X */
X#include "EXTERN.h"
X#include "perl.h"
X#undef MAX
X#undef MIN
X
X#if !defined(VERSION3)
X#define str_2static(s)        str_2mortal(s)
X#endif
X
X#include <sybfront.h>
X#include <sybdb.h>
X#include <syberror.h>
X
X#include "patchlevel.h"
X
Xextern int wantarray;
X
Xchar *savestr();
X
X
X/*
X * The variables that the Sybase routines set, and that you may want
X * to test in your Perl script. These variables are READ-ONLY.
X */
Xstatic enum uservars
X{
X    UV_SUCCEED,            /* Returns SUCCEED */
X    UV_FAIL,            /* Returns FAIL */
X    UV_NO_MORE_ROWS,        /* Returns NO_MORE_ROWS */
X    UV_NO_MORE_RESULTS,        /* Returns NO_MORE_RESULTS */
X    UV_ComputeId,        /* Returns the compute id of the row (in dbnextrow()) */
X    UV_SybperlVer,        /* Returns Sybperl Version/Patchlevel */
X};
X
X/*
X * User subroutines that we have implemented. I've found that I can do
X * all the stuff I want to with this subset of DB-Library. Let me know
X * if you implement further routines.
X * The names are self-explanatory.
X */
Xstatic enum usersubs
X{
X    US_dblogin,            /* This also performs a dbopen()  */
X    US_dbopen,
X    US_dbclose,
X    US_dbcmd,
X    US_dbsqlexec,
X    US_dbresults,
X    US_dbnextrow,
X    US_dbcancel,
X    US_dbcanquery,
X    US_dbexit,
X    US_dbuse,
X};
X
X#define MAX_DBPROCS 25        /* Change this if you really want your perl script to talk to */
X                /* more than 25 dataserver connections at a time ...*/
X
Xstatic LOGINREC *login;
Xstatic DBPROCESS *dbproc[MAX_DBPROCS];
Xstatic int exitCalled = 0;    /* Set to 1 if dbexit() has been called. */
Xstatic int ComputeId;
X
Xstatic int usersub();
Xstatic int userset();
Xstatic int userval();
Xstatic int err_handler(), msg_handler();
X
Xint userinit()
X{
X    init_sybase();
X}
X
Xint
Xinit_sybase()
X{
X    struct ufuncs uf;
X    char *filename = "sybase.c";
X
X    if (dbinit() == FAIL)    /* initialize dblibrary */
X    exit(ERREXIT);
X/*
X * Install the user-supplied error-handling and message-handling routines.
X * They are defined at the bottom of this source file.
X */
X    dberrhandle(err_handler);
X    dbmsghandle(msg_handler);
X
X    uf.uf_set = userset;
X    uf.uf_val = userval;
X
X#define MAGICVAR(name, ix) uf.uf_index = ix, magicname(name, &uf, sizeof uf)
X
X    MAGICVAR("SUCCEED",    UV_SUCCEED);
X    MAGICVAR("FAIL",UV_FAIL);
X    MAGICVAR("NO_MORE_ROWS",    UV_NO_MORE_ROWS);
X    MAGICVAR("NO_MORE_RESULTS",    UV_NO_MORE_RESULTS);
X    MAGICVAR("ComputeId",    UV_ComputeId);
X    MAGICVAR("SybperlVer",    UV_SybperlVer);
X
X    make_usub("dblogin",    US_dblogin,    usersub, filename);
X    make_usub("dbopen",        US_dbopen,    usersub, filename);
X    make_usub("dbclose",    US_dbclose,    usersub, filename);
X    make_usub("dbcmd",        US_dbcmd,    usersub, filename);
X    make_usub("dbsqlexec",    US_dbsqlexec,    usersub, filename);
X    make_usub("dbresults",    US_dbresults,    usersub, filename);
X    make_usub("dbnextrow",    US_dbnextrow,    usersub, filename);
X    make_usub("dbcancel",    US_dbcancel,    usersub, filename);
X    make_usub("dbcanquery",    US_dbcanquery,    usersub, filename);
X    make_usub("dbexit",    US_dbexit,    usersub, filename);
X    make_usub("dbuse",    US_dbuse,    usersub, filename);
X
X}
X
Xstatic int
Xusersub(ix, sp, items)
Xint ix;
Xregister int sp;
Xregister int items;
X{
X    STR **st = stack->ary_array + sp;
X    ARRAY *ary = stack;
X    register int i;
X    register STR *Str;        /* used in str_get and str_gnum macros */
X    int inx = -1;        /* Index into dbproc[] array. Passed as first parameter to nearly all &dbxxx() calls */
X
X    if(exitCalled)
X    fatal("&dbexit() has been called. Access to Sybase impossible.");
X
X    switch (ix)
X    {
X      case US_dblogin:
X    if (items > 2)
X        fatal("Usage: &dblogin([user[,pwd]])");
X    if (login)
X        fatal("&dblogin() called twice.");
X    else
X    {
X        int retval;
X
X        login = dblogin();
X        if(items)
X        {
X        DBSETLUSER(login, (char *)str_get(st[1]));
X        if(items > 1)
X            DBSETLPWD(login, (char *)str_get(st[2]));
X        }
X
X        dbproc[0] = dbopen(login, NULL);
X        str_numset(st[0], (double) 0);
X    }
X    break;
X      case US_dbopen:
X    if (items != 0)
X        fatal("Usage: $dbproc = &dbopen;");
X    else
X    {
X        int j;
X
X        for(j = 0; j < MAX_DBPROCS; ++j)
X        if(dbproc[j] == NULL)
X            break;
X        if(j == MAX_DBPROCS)
X        fatal("&dbopen: No more dbprocs available.");
X        dbproc[j] = dbopen(login, NULL);
X        str_numset(st[0], (double) j);
X    }
X    break;
X      case US_dbclose:
X    if (items != 1)
X        fatal("Usage: $ret = &dbclose($dbproc);");
X    else
X    {
X        inx = getDbProc(st[1]);
X
X        dbclose(dbproc[inx]);
X        dbproc[inx] = (DBPROCESS *)NULL;
X    }
X    break;
X      case US_dbcancel:
X    if (items != 1)
X        fatal("Usage: &dbcancel($dbproc)");
X    else
X    {
X        int retval;
X#if defined(BROKEN_DBCMD)
X        DBSTRING *ptr;
X        DBSTRING *old;
X#endif
X        inx = getDbProc(st[1]);
X
X        retval = dbcancel(dbproc[inx]);
X        str_numset(st[0], (double) retval);
X#if defined(BROKEN_DBCMD)
X        ptr = dbproc[inx]->dbcmdbuf;
X        while(ptr)
X        {
X        old = ptr;
X        ptr = ptr->strnext;
X        free(old->strtext);
X        free(old);
X        }
X        dbproc[inx]->dbcmdbuf = NULL;
X#endif
X    }
X    break;
X
X      case US_dbcanquery:
X    if (items != 1)
X        fatal("Usage: &dbcanquery($dbproc)");
X    else
X    {
X        int retval;
X        inx = getDbProc(st[1]);
X
X        retval = dbcanquery(dbproc[inx]);
X        str_numset(st[0], (double) retval);
X    }
X    break;
X
X      case US_dbexit:
X    if (items != 0)
X        fatal("Usage: &dbexit()");
X    else
X    {
X        dbexit(dbproc[0]);
X        exitCalled++;
X        str_numset(st[0], (double) 1);
X    }
X    break;
X
X      case US_dbuse:
X    if (items != 2)
X        fatal("Usage: &dbuse($dbproc, $database)");
X    else
X    {
X#if defined(BROKEN_DBCMD)
X        /*
X         * Why doesn't this $@#! dbuse() call not work from within
X         * Perl????? (So we emulate it here, but I sure can't
X         * guarantee anything about portability to future versions
X         * of DB-Library!
X         */
X        DBSTRING *new;
X        DBSTRING *sav;
X        char *strdup();
X        char buff[256];
X        int ret;
X
X        inx = getDbProc(st[1]);
X
X        strcpy(buff, "use ");
X        strcat(buff, (char *)str_get(st[2]));
X        sav = dbproc[inx]->dbcmdbuf;
X
X        new = (DBSTRING *)calloc(1,sizeof(DBSTRING));
X        new->strtext = (BYTE *)strdup((char *)buff);
X        new->strtotlen = strlen(new->strtext)+1;
X        dbproc[inx]->dbcmdbuf = new;
X
X        ret = dbsqlexec(dbproc[inx]);
X        ret = dbresults(dbproc[inx]);
X        while((ret = dbnextrow(dbproc[inx])) != NO_MORE_ROWS)
X        ;
X
X        free(new->strtext);
X        free(new);
X
X        dbproc[inx]->dbcmdbuf = sav;
X        str_numset(st[0], (double) SUCCEED);
X#else
X        int retval;
X        char str[255];
X        strcpy(str, (char *)str_get(st[2]));
X        inx = getDbProc(st[1]);
X
X        retval = dbuse(dbproc[inx], str);
X        str_numset(st[0], (double) retval);
X#endif
X    }
X    break;
X
X      case US_dbsqlexec:
X    if (items != 1)
X        fatal("Usage: &dbsqlexec($dbproc)");
X    else
X    {
X        int retval;
X        inx = getDbProc(st[1]);
X
X        retval = dbsqlexec(dbproc[inx]);
X        str_numset(st[0], (double) retval);
X    }
X    break;
X
X      case US_dbresults:
X    if (items != 1)
X        fatal("Usage: &dbresults($dbproc)");
X    else
X    {
X        int retval;
X        inx = getDbProc(st[1]);
X
X        retval = dbresults(dbproc[inx]);
X        str_numset(st[0], (double) retval);
X#if defined(BROKEN_DBCMD)
X        if(retval==NO_MORE_RESULTS)
X        {
X        DBSTRING *ptr = dbproc[inx]->dbcmdbuf;
X        DBSTRING *old;
X
X        while(ptr)
X        {
X            old = ptr;
X            ptr = ptr->strnext;
X            free(old->strtext);
X            free(old);
X        }
X        dbproc[inx]->dbcmdbuf = NULL;
X        }
X#endif
X    }
X    break;
X
X      case US_dbcmd:
X    if (items != 2)
X        fatal("Usage: &dbcmd($dbproc, $str)");
X    else
X    {
X        int retval;
X#if defined(BROKEN_DBCMD)
X        DBSTRING *ptr;
X        DBSTRING *new, *old;
X        char *strdup();
X#endif
X        inx = getDbProc(st[1]);
X
X#if defined(BROKEN_DBCMD)
X        ptr = dbproc[inx]->dbcmdbuf;
X
X        new = (DBSTRING *)calloc(1,sizeof(DBSTRING));
X        new->strtext = (BYTE *)strdup((char *)str_get(st[2]));
X        new->strtotlen = strlen(new->strtext)+1;
X        if(!ptr)
X        dbproc[inx]->dbcmdbuf = new;
X        else
X        {
X        while(ptr->strnext)
X            ptr = ptr->strnext;
X        ptr->strnext = new;
X        }
X#else
X        retval = dbcmd(dbproc[inx], (char *)str_get(st[2]));
X#endif
X        str_numset(st[0], (double) retval);
X    }
X    break;
X
X    case US_dbnextrow:
X    if (items != 1)
X        fatal("Usage: @arr = &dbnextrow($dbproc)");
X    else
X    {
X        int retval;
X        inx = getDbProc(st[1]);
X
X        --sp;        /* otherwise you get an empty element at the beginning of the results array! */
X
X        retval = dbnextrow(dbproc[inx]);
X        if(retval == REG_ROW)
X        {
X            char buff[1024], *p;
X        BYTE *data;
X        int col, type, numcols = dbnumcols(dbproc[inx]);
X        int len;
X        DBFLT8 tmp;
X
X        ComputeId = 0;
X
X        for(col = 1, buff[0] = 0; col <= numcols; ++col)
X        {
X            type = dbcoltype(dbproc[inx], col);
X            len = dbdatlen(dbproc[inx],col);
X            data = (BYTE *)dbdata(dbproc[inx],col);
X            if(!data && !len)
X            {
X            strcpy(buff,"NULL");
X            }
X            else
X            {
X            switch(type)
X            {
X              case SYBCHAR:
X                strncpy(buff,data,len);
X                buff[len] = 0;
X                break;
X              case SYBINT1:
X              case SYBBIT: /* a bit is at least a byte long... */
X                sprintf(buff,"%u",*(unsigned char *)data);
X                break;
X              case SYBINT2:
X                sprintf(buff,"%d",*(short *)data);
X                break;
X              case SYBINT4:
X                sprintf(buff,"%d",*(long *)data);
X                break;
X              case SYBFLT8:
X                sprintf(buff,"%.6f",*(double *)data);
X                break;
X              case SYBMONEY:
X                dbconvert(dbproc[inx], SYBMONEY, data,-1,SYBFLT8,&tmp,-1);
X                sprintf(buff,"%.6f",tmp);
X                break;
X              case SYBDATETIME:
X                dbconvert(dbproc[inx], SYBDATETIME, data,-1,SYBCHAR,buff,-1);
X                break;
X              default:
X                /* ignored at the moment... */
X                break;
X            }
X            }
X            (void)astore(ary,++sp,str_2static(str_make(buff,0)));
X        }
X        }
X        if (retval > 0)
X        {
X            char buff[1024], *p;
X        BYTE *data;
X        int col, type, numcols;
X        int len;
X        DBFLT8 tmp;
X
X        ComputeId = retval;
X        numcols = dbnumalts(dbproc[inx], ComputeId);
X
X        for(col = 1, buff[0] = 0; col <= numcols; ++col)
X        {
X            type = dbalttype(dbproc[inx], ComputeId, col);
X            len = dbadlen(dbproc[inx], ComputeId, col);
X            data = (BYTE *)dbadata(dbproc[inx], ComputeId, col);
X            if(!data && !len)
X            {
X            strcpy(buff,"NULL");
X            }
X            else
X            {
X            switch(type)
X            {
X              case SYBCHAR:
X                strncpy(buff,data,len);
X                buff[len] = 0;
X                break;
X              case SYBINT1:
X              case SYBBIT: /* a bit is at least a byte long... */
X                sprintf(buff,"%d",*(char *)data);
X                break;
X              case SYBINT2:
X                sprintf(buff,"%d",*(short *)data);
X                break;
X              case SYBINT4:
X                sprintf(buff,"%d",*(long *)data);
X                break;
X              case SYBFLT8:
X                sprintf(buff,"%.6f",*(double *)data);
X                break;
X              case SYBMONEY:
X                dbconvert(dbproc[inx], SYBMONEY, data,-1,SYBFLT8,&tmp,-1);
X                sprintf(buff,"%.6f",tmp);
X                break;
X              case SYBDATETIME:
X                dbconvert(dbproc[inx], SYBDATETIME, data,-1,SYBCHAR,buff,-1);
X                break;
X              default:
X                /* ignored at the moment... */
X                break;
X            }
X            }
X            (void)astore(ary,++sp,str_2static(str_make(buff,0)));
X        }
X        }
X#if defined(BROKEN_DBCMD)
X        /*
X         * We can't rely on dbcmd(),dbresults() etc. to clean up
X         * the dbcmdbuf linked list, so we have to it ourselves...
X         */
X        if(retval == NO_MORE_ROWS && !DBMORECMDS(dbproc[inx]))
X        {
X        DBSTRING *ptr = dbproc[inx]->dbcmdbuf;
X        DBSTRING *new, *old;
X
X        while(ptr)
X        {
X            old = ptr;
X            ptr = ptr->strnext;
X            free(old->strtext);
X            free(old);
X        }
X        dbproc[inx]->dbcmdbuf = NULL;
X        }
X#endif
X    }
X    break;
X
X    default:
X    fatal("Unimplemented user-defined subroutine");
X    }
X    return sp;
X}
X
X/*
X * Return the value of a userdefined variable. These variables are all
X * READ-ONLY in Perl.
X */
Xstatic int
Xuserval(ix, str)
Xint ix;
XSTR *str;
X{
X    char buff[24];
X
X    switch (ix)
X    {
X      case UV_SUCCEED:
X    str_numset(str, (double)SUCCEED);
X    break;
X      case UV_FAIL:
X    str_numset(str, (double)FAIL);
X    break;
X      case UV_NO_MORE_ROWS:
X    str_numset(str, (double)NO_MORE_ROWS);
X    break;
X      case UV_NO_MORE_RESULTS:
X    str_numset(str, (double)NO_MORE_RESULTS);
X    break;
X      case UV_ComputeId:
X    str_numset(str, (double)ComputeId);
X    break;
X      case UV_SybperlVer:
X    sprintf(buff, "%d.%3.3d", VERSION, PATCHLEVEL);
X    str_set(str, buff);
X    break;
X    }
X    return 0;
X}
X
Xstatic int
Xuserset(ix, str)        /* Not used. None of these variables are user-settable */
Xint ix;
XSTR *str;
X{
X    return 0;
X}
X
X
X/*ARGSUSED*/
Xstatic int err_handler(dbprocl, severity, dberr, oserr, dberrstring, oserrstr)
X    DBPROCESS *dbprocl;
X    int severity;
X    int dberr;
X    int oserr;
X    char *dberrstring;
X    char *oserrstr;
X{
X    if ((dbprocl == NULL) || (DBDEAD(dbprocl)))
X    return(INT_EXIT);
X    else
X    {
X    fprintf(stderr,"DB-Library error:\n\t%s\n", dberrstring);
X
X    if (oserr != DBNOERR)
X        fprintf(stderr,"Operating-system error:\n\t%s\n", oserrstr);
X
X    return(INT_CANCEL);
X    }
X}
X
X/*ARGSUSED*/
X
Xstatic int msg_handler(dbprocl, msgno, msgstate, severity, msgtext, srvname, procname, Line)
X    DBPROCESS *dbprocl;
X    DBINT msgno;
X    int msgstate;
X    int severity;
X    char *msgtext;
X    char *srvname;
X    char *procname;
X    DBUSMALLINT Line;
X{
X    if(msgno != 5701)        /* Ignore 'Changed database context' messages */
X    {
X    fprintf (stderr,"Msg %ld, Level %d, State %d\n",
X         msgno, severity, msgstate);
X    if (strlen(srvname) > 0)
X        fprintf (stderr,"Server '%s', ", srvname);
X    if (strlen(procname) > 0)
X        fprintf (stderr,"Procedure '%s', ", procname);
X    if (Line > 0)
X        fprintf (stderr,"Line %d", Line);
X
X    fprintf(stderr,"\n\t%s\n", msgtext);
X    }
X
X    if(severity)
X    exit(-1);
X
X    return(0);
X}
X
X/*
X * Get the index into the dbproc[] array from a Perl STR datatype.
X * Check that the index is reasonably valid...
X */
Xint getDbProc(Str)
X    STR *Str;
X{
X    int ix = (int)str_gnum(Str);
X
X    if(ix < 0 || ix >= MAX_DBPROCS)
X    fatal("$dbproc parameter is out of range.");
X    return ix;
X}
X

SHAR_EOF
if test 15591 -ne "`wc -c < 'sybperl.c'`"
then
    echo shar: error transmitting "'sybperl.c'" '(should have been 15591 characters)'
fi
fi
chmod 444 sybperl.c
if test -f 'sybperl.1'
then
    echo shar: will not over-write existing file "'sybperl.1'"
else
    echo x - 'sybperl.1'
    sed 's/^X//' >'sybperl.1' << 'SHAR_EOF'
X.\".po 4
X.TH SYBPERL 1 "3 September 1991"
X.ad
X.nh
X.SH NAME
Xsybperl \- Perl access to Sybase databases
X.SH SYNOPSIS
X.nf
X$dbproc  = &dblogin([$user[, $pwd]])
X$dbproc1 = &dbopen()
X       &dbclose($dbproc)
X$ret     = &dbcmd($dbproc, $sql_cmd)
X$ret     = &dbsqlexec($dbproc)
X$ret     = &dbresults($dbproc)
X@data    = &dbnextrow($dbproc)
X$ret     = &dbuse($dbproc, $database)
X$ret     = &dbcancel($dbproc)
X$ret     = &dbcanquery($dbproc)
X$ret     = &dbexit($dbproc)
X
X$SUCCEED
X$FAIL
X$NO_MORE_ROWS
X$NO_MORE_RESULTS
X$ComputeId
X$SybperlVer
X.fi
X.SH DESCRIPTION
X\fBSybperl\fP is a version of \fIPerl\fP which has been extended (via
Xthe \fIusersubs\fP feature) to allow access to \fISybase\fP databases.
X.SH Functions
X\fBSybperl\fP basically maps the calls existing in the \fISybase
XDB-Library\fP to \fIPerl\fP. The usage of these fcuntions is the same
Xas in \fIDB-Library\fP, unless specifically noted.
X
XThe following functions are provided:
X
X.nf
X\fB$dbproc  = &dblogin([$user[, $pwd]])\fP
X\fB&dbproc1 = &dbopen()\fP
X\fB          &dbclose($dbproc)\fP
X\fB$status  = &dbcmd($dbproc, $sql_cmd)\fP
X\fB$status  = &dbsqlexec($dbproc)\fP
X\fB$status  = &dbresults($dbproc)\fP
X\fB@data    = &dbnextrow($dbproc)\fP
X\fB$status  = &dbuse($dbproc, $database)\fP
X\fB$status  = &dbcancel($dbproc)\fP
X\fB$status  = &dbcanquery($dbproc)\fP
X\fB$status  = &dbexit($dbproc)\fP
X.fi
X
XDifferences with DB-Library:
X
X\fB&dblogin\fP takes 2 optional arguements (the userid and the
Xpassword). These default to the Unix userid, and the null password.
X
X\fB&dblogin\fP returns a \fBDBPROCESS\fP, not a \fBLOGINREC\fP. This
Xsimplifies the call to open a connection to a Sybase dataserver
Xsomewhat. Further \fBDBPROCESSes\fP can be opened using
X\fB&dbopen()\fP (No arguments). The number of simultaneous DBPROCESSes
Xis limited to 25 (This can be changed by altering a #define in sybperl.c).
X
X\fB&dbnextrow\fP returns an array of formatted data, based on the
Xdatatype of the corresponding columns. \fB&dbnextrow\fP sets the
Xvariable \fB$ComputeId\fP when the result row is a computed row (the
Xresult of a \fIcompute by\fP clause).
X
X.SH "UNIMPLEMENTED FEATURES"
X
XThe \fBSYBIMAGE\fP and \fBSYBTEXT\fP are not implemented.
X
X\fB&dbfcmd\fP is not implemented, but can be emulated by using
X\fIsprintf\fP as in \fI&dbcmd($dbproc, sprintf("%d", $num_val))\;\fP
X
XOne cannot log in to a specific server (ie \fIdbopen()\fP is always
Xcalled with a \fINULL\fP second parameter.
X
X.SH OPTIONS
X
XSee the \fIPerl(1)\fP manual page.
X
X.SH FILES
X
X\fI$PERLLIB/sybperl.pl\fP should be called in all \fBsybperl\fP
Xscripts to set the correct environment variables used by DB-Library.
X
X.SH "SEE ALSO"
X
X\fIPerl(1), Sybase Open Client DB Library Reference Manual.\fP
X
X.SH AUTHOR
X
XMichael Peppler, ITF Management SA \- [e-mail]
SHAR_EOF
if test 2755 -ne "`wc -c < 'sybperl.1'`"
then
    echo shar: error transmitting "'sybperl.1'" '(should have been 2755 characters)'
fi
fi
chmod 664 sybperl.1
if test -f 'patchlevel.h'
then
    echo shar: will not over-write existing file "'patchlevel.h'"
else
    echo x - 'patchlevel.h'
    sed 's/^X//' >'patchlevel.h' << 'SHAR_EOF'
X#define VERSION 1
X#define PATCHLEVEL 3

SHAR_EOF
if test 40 -ne "`wc -c < 'patchlevel.h'`"
then
    echo shar: error transmitting "'patchlevel.h'" '(should have been 40 characters)'
fi
fi
chmod 664 patchlevel.h
if test ! -d 'lib'
then
    mkdir 'lib'
fi
if test -f 'lib/sybperl.pl'
then
    echo shar: will not over-write existing file "'lib/sybperl.pl'"
else
    echo x - 'lib/sybperl.pl'
    sed 's/^X//' >'lib/sybperl.pl' << 'SHAR_EOF'
X;#     @(#)sybperl.pl    1.1    9/3/91
X
X;# This file, when interpreted, sets the appropriate environment
X;# variables for Sybase's use DB-Library & isql.
X;#
X;# usage:
X;#    require 'sybperl.pl';
X;#
X;# We don't set the environment if it is already set.
X
X
X$ENV{'SYBASE'} = "/usr/local/sybase" unless $ENV{'SYBASE'};
X$ENV{'DSQUERY'}= "SYBASE" unless $ENV{'DSQUERY'};
X$ENV{'PATH'}="$ENV{'PATH'}:$ENV{'SYBASE'}/bin" unless $ENV{'PATH'} =~ /$ENV{'SYBASE'}/;

SHAR_EOF
if test 441 -ne "`wc -c < 'lib/sybperl.pl'`"
then
    echo shar: error transmitting "'lib/sybperl.pl'" '(should have been 441 characters)'
fi
fi
chmod 444 lib/sybperl.pl
if test ! -d 't'
then
    mkdir 't'
fi
if test -f 't/sbex.pl'
then
    echo shar: will not over-write existing file "'t/sbex.pl'"
else
    echo x - 't/sbex.pl'
    sed 's/^X//' >'t/sbex.pl' << 'SHAR_EOF'
X#!../sybperl
X
X
X@nul = ('not null','null');
X@sysdb = ('master', 'model', 'tempdb');
X
Xrequire "../lib/sybperl.pl";
X
Xprint "Sybperl version $SybperlVer\n\n";
X
Xprint "This script tests some of sybperl's functions, and prints out\n";
Xprint "description of the databases that are defined in your Sybase\n";
Xprint "dataserver.\n\n";
X
X
X$dbproc = &dblogin("sa");    # Login to sybase
X
X$dbproc2 = &dbopen;        # Get a second dbprocess, so that we can select from several
X                                # chanels simultaneously. We could code things so that this
X                # feature is unnecessary, but it's good to exercise it.
X
X                # First, find out what databases exist:
X&dbcmd($dbproc, "select name from sysdatabases order by crdate\n");
X&dbsqlexec($dbproc);
X&dbresults($dbproc);
X
Xdatabase: while((@db = &dbnextrow($dbproc)))
X{
X    foreach $nm (@sysdb)
X    {
X    if($db[0] =~ /$nm/)
X    {
X        print "'$db[0]' is a system database\n";
X        next database;
X    }
X    }
X    print "Finding user tables in user database $db[0]...";
X
X    &dbcmd($dbproc2, "select o.name, u.name, o.id\n"); #
X    &dbcmd($dbproc2, "from $db[0].dbo.sysobjects o, $db[0].dbo.sysusers u\n");
X    &dbcmd($dbproc2, "where o.type = 'U' and u.uid = o.uid\n");
X    &dbcmd($dbproc2, "order by o.name\n");
X
X    &dbsqlexec($dbproc2);
X    &dbresults($dbproc2);
X
X    while((@dat = &dbnextrow($dbproc2)))
X    {
X    $tab = join('@', @dat);    # Save the information
X    push(@tables, $tab);    # for later use...
X    }
X    print "Done.\n";
X
X    print "Finding user defined datatypes in database $db[0]...\n";
X
X    &dbcmd($dbproc2, "select s.length,substring(s.name,1,30),substring(st.name,1,30)\n");
X    &dbcmd($dbproc2, "from   $db[0].dbo.systypes s, $db[0].dbo.systypes st\n");
X    &dbcmd($dbproc2, "where  st.type = s.type\n");
X    &dbcmd($dbproc2, "and s.usertype > 100 and st.usertype < 100 and st.usertype != 18\n");
X    &dbsqlexec($dbproc2);
X    &dbresults($dbproc2);
X
X    while((@dat = &dbnextrow($dbproc2)))
X    {
X    print "sp_addtype $dat[1],";
X    if ($dat[2] =~ /char|binary/)
X    {
X        print "'$dat[2]($dat[0])'";
X    }
X    else
X    {
X        print "$dat[2]";
X    }
X    print "\n";
X
X    }
X    print "Done.\n";
X
X    print "Now we find the table definition for each user table\nin database $db[0]...\n";
X
X    foreach $ln (@tables)        # For each line in the list
X    {
X    @tab = split('@',$ln);
X
X    &dbcmd($dbproc2, "select Column_name = c.name, \n");
X    &dbcmd($dbproc2, "       Type = t.name, \n");
X    &dbcmd($dbproc2, "       Length = c.length, \n");
X    &dbcmd($dbproc2, "       Nulls = convert(bit, (c.status & 8))\n");
X    &dbcmd($dbproc2, "from   $db[0].dbo.syscolumns c, $db[0].dbo.systypes t\n");
X    &dbcmd($dbproc2, "where  c.id = $tab[2]\n");
X    &dbcmd($dbproc2, "and    c.usertype *= t.usertype\n");
X
X    &dbsqlexec($dbproc2);
X    &dbresults($dbproc2);
X
X    print "\nTABLE $db[0].$tab[1].$tab[0]\n (";
X    $first = 1;
X    while((@field = &dbnextrow($dbproc2)))
X    {
X        print ",\n" if !$first;        # add a , and a \n if not first field in table
X
X        print "\t$field[0] \t$field[1]";
X        print "($field[2])" if $field[1] =~ /char|bin/;
X        print " $nul[$field[3]]";
X
X        $first = 0 if $first;
X    }
X    print " )\n";
X
X# now get the indexes...
X#
X    print "\nIndexes on $db[0].$tab[0].$tab[1]...\n\n";
X    &dbuse($dbproc2, $db[0]);
X    &dbcmd($dbproc2, "sp_helpindex '$tab[1].$tab[0]'\n");
X
X    &dbsqlexec($dbproc2);
X    &dbresults($dbproc2);
X
X    while((@field = &dbnextrow($dbproc2)))
X    {
X        print "unique " if $field[1] =~ /unique/;
X        print "clustered " if $field[1] =~ /^clust/;
X        print "index $field[0]\n";
X        @col = split(/,/,$field[2]);
X        print "on $db[0].$tab[1].$tab[0] (";
X        $first = 1;
X        foreach $ln1 (@col)
X        {
X        print ", " if !$first;
X        $first = 0;
X        print "$ln1";
X        }
X        print ")\n";
X    }
X    print "\nDone.\n";
X    }
X    &dbuse($dbproc2, "master");
X    @tables = ();
X}
X
X&dbexit;

SHAR_EOF
if test 3784 -ne "`wc -c < 't/sbex.pl'`"
then
    echo shar: error transmitting "'t/sbex.pl'" '(should have been 3784 characters)'
fi
fi
chmod 775 t/sbex.pl
echo Done
exit 0

exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].